perm filename DRAW.F4[DRW,LCS]1 blob sn#163320 filedate 1975-06-11 generic text, type T, neo UTF8
00100	C TYPE 'DO DOD.DO'.
00110	C  'G' OR <CR> = GET.  'A'=ADD TO COMBINED FILE.
00200	C PC=PLOT  PX=XGP(→PLOT.BIN)  PXS,PCS=PLOT SMOOTHED CONTURE
00300	C  PXZ,PCZ=PLOT SMOOTHED CONTURE AND FILL IT.
00400	C IN DRAW SECTION: J=JUMP(INVIS. VECT.)
00500	C  F=JUMP AND BEGIN FILL SECTION.  FX=EXIT AND FILL ALL.
00600	C SINGLE ITEM IS RESTRICTED TO 350 WDS. 10 ITEMS OR 350 WDS PER FILE.
00610	C  'Q' MAKES CURRENT DPY IN BACKGROUND ON POG2
00700		COMMON /RC/MCLEF(400),IST(4000)
00800		COMMON /FL/IC,N,NQ,RZ,IXRX,XGP,RXGP
00900		COMMON/ZN/SCLEF(400,2),DDD /ED/KED,NEXT,NN,NX,NY,J
01100		COMMON XX(100),G(100),NJ,QF(512),RF(512),S(100),K
01300		DIMENSION JCLEF(10),KCLEF(10),NMLST(10),JST(1)
01400		COMMON/NFF/NF(513) /LL/LL /RZ/RSZ,IPLT,RJB,CENTR
01460		EQUIVALENCE (MM,SCLEF(1,1)),(JCLEF,IST(1490)),(NM,IXRX)
01510		1 ,(GRID,IST(4000)),(KCLEF,IST(1500))
01600		1 ,(NMLST,IST(1510)),(JST,IST(500))
01700		DATA RJB/-20./,CENTR/-26./
01710		RSZ=0
01800	1	MCLEF(1)=0
02000		MM=0
02100		IPLT=0
02200		IPLTX=-1
02300		K=1
02500	91	TYPE 100
02600	55	FORMAT(I,2F)
02700	50	FORMAT(3A1)
02900		XSZ=RSZ
03000		ACCEPT 55,J,RSZ,GRID
03200		IF(RSZ.EQ.0)RSZ=XSZ
03300		MORE=-1
03400		REREAD 50,N,JC,JS
03410		IF(N.EQ.' ')GO TO 91
03500	C PXS,PCS=SMOOTH ONLY;  PXZ,PCZ=SMOOTH AND FILL
03600	C  TO SAVE SIZE FACTOR WHEN REDRAWING.
03610		IF(N.EQ.'Z')GO TO 1
03700		IF(RSZ.EQ.0)RSZ=9.0
03710		IF(GRID.NE.0.AND.N.NE.'P')CALL GRIDS
03800		IF(N.EQ.'M'.OR.N.EQ.'R')GO TO 192
03850		IF(N.EQ.'V')CALL CNVT
03875	C  V=CONVERT FROM OLD FORMAT TO NEW.
03900	C  FOR ROTATION OR MOVING AND DISTORTING ENTIRE PICTURE
03910		IF(N.EQ.'F')GO TO 79
03930	C  FILLS IT.
03950		IF(JS.EQ.'L')N='Z'
03975	C  DEL=DELETE FROM COMB. FILE.   (JS='L')
04000		IF(N.EQ.'C'.OR.N.EQ.'A'.OR.N.EQ.'Z')GO TO 999
04100	CC	IF(N.EQ.'X')CALL EXIT
04300		IF(N.EQ.'Q')GO TO 56
04350	C  'Q' MAKES CURRENT DPY IN BACKGROUND ON POG2
04400		IF(N.NE.'D'.AND.N.NE.'E')GO TO 191
04410	CC	IF(JC.EQ.'X')MCLEF(1)=0
04420	C  TYPE 'DX' TO START NEW DRAWING WITHOUT EXIT. (GOOD AFTER 'Q')
04500	
04600		KED=N
04700		MM=MCLEF(1)
04800		IF(MM.NE.0)GO TO 92
04900	C  ADD TO DRAWING?
05000		GO TO 3
05010	
05020	56	CALL POG2
05030		CALL RDRAW(2,MCLEF(1),MCLEF)
05035		CALL DPYOUT(2)
05040		CALL POG1
05050		GO TO 91
05100	999	CALL CMBN
05200		GO TO 111
05250	CC192	IF(N.EQ.'R')MCLEF(1)=-MCLEF(1)
05300	192	CALL SHIFT(MCLEF(2),MCLEF(1),N)
05400		J=1
05500		JC=0
05600		GO TO 333
05700	191	TYPE 41
05900		IF(JC.EQ.'M')GO TO 194
05950		IF(N.EQ.'S')GO TO 194
06000		MCLEF(1)=0
06100		MM=0
06200		IPLTX=-1
06300		K=1
06400	194	IF(JC.EQ.'M')MORE=0
06500		JQ=JC
06600		JC=0
06700		JM=1
06900		IF(MCLEF(1).EQ.0)GO TO 193
07000	CC	JC=JCLEF(2)-1
07100	CC	JM=MCLEF(1)+1
07140		JM=MCLEF(1)+1
07200	193	ACCEPT 10,NM,PASS
07210		IF(NM.EQ.' ')NM=LASTNM
07300		IF(NM.EQ.' ')GO TO 91
07302		IF(NM.EQ.'99')GO TO 91
07305	C  '99'  WILL BACKUP
07310		IF(N.NE.'S')LASTNM=NM
07400	CC	REWIND 1
07500		IF(N.EQ.'S')GO TO 40
07600		IF(LOOKF(NM).EQ.0)GO TO 191
07700	C  'FAIL' ROUTINE TO CHECK ON LOOKUP
07800	CC	CALL IFILE(1,NM)
07900	CC	READ(1,5)M,JCLEF
07950		CALL RDSAV(KCLEF,NMLST,M,NM,JST,-1)
07970	C  -1=READ
08000	C  CAN'T USE 'GM' WITH 'COMBINED' FILE.
08002	CC	JQ=0
08005	CC	IF(MORE.EQ.0.AND.JCLEF(3).NE.0)JQ=JM-1
08010		J=1
08020		IF(KCLEF(2).EQ.0)GO TO 290
08060	CC	IF(PASS.NE.0)CALL ITEM
08100		TYPE 1100
08200		ACCEPT 55,J
08300		J=J+1
08350	C  ITEMS ARE NUMBERED  0 THROUGH 9 (10 ITEMS).
08375		IF(J.GT.10)GO TO 191
08400	CC290	IC=KCLEF(K+1)-KCLEF(K)
08420	290	IC=KCLEF(J)+JST(KCLEF(J))-1
08450	CC	IF(J.EQ.10)IC=1000
08500		TYPE 110,IC
09910	60	JZ=1
09917		IF(MORE.EQ.0)JZ=JM
09920		L=KCLEF(J)-1
09921		M=JST(L+1)+JZ-1
09922		IF(MORE.NE.0)GO TO 161
09923		M=M-1
09924		L=L+1
09930	161	DO 61 K=JZ,M
09935		L=L+1
09937	CJ	M=K
09940	61	MCLEF(K)=JST(L)
09960		MCLEF(1)=M
10000	1100	FORMAT(' ITEM NUM?'/)
10100	700	FORMAT(' RESET X-Y POS. ',$)
10200	555	FORMAT(2F)
10300	7	IF(MORE)GO TO 70
10400		DO 771 K=2,JM-1
10500	771	IF(MCLEF(K).GE.200000000)GO TO 772
10600		GO TO 70
11200	C PUTS FILLER TO END
11400	C  MOVES OUTLINE UP FRONT
11710	772	M=MCLEF(1)
11720		DO 773 L=K,JM
11730		M=M+1
11740	773	MCLEF(M)=MCLEF(L)
11750	CJ	K=MJ+K
11755		K=JM-K  
11760	1774	DO 774 L=JM,M
11770	774	MCLEF(L-K)=MCLEF(L)
11800		GO TO 3
12600	
12700	70	IF(N.NE.'P')GO TO 3
12800		IXRX=-1
12900		IF(JQ.NE.'X')IXRX=0
13000	C 0=SEND IT TO CALCOMP
13100		TYPE 700
13200		ACCEPT 555,X,Y
13300		IF(X.NE.0)RJB=X/RSZ
13400		IF(Y.NE.0)CENTR=Y/RSZ
13500	C  TYPE .001, .001 TO SET POS. TO 0, -20, -26 IS ORIGINAL.
13600		IF(IPLTX)CALL PLOTS(0)
13700	C  DO I NEED THIS?
13710		IF(GRID.GT.0)CALL GRIDS
13800		IPLTX=0
13900		IPLT=-1
14000	3	IF(N.NE.'D')MM=0
14100	C  RESET IF NOT GOING TO DRAWIT
14400	333	IF(N.EQ.'P')GO TO 337
14500		CALL DPYSET(1,IST,4000)
14600		CALL DPYBRT(4)
14700		NIST=IST(2)
14800		IF(N.GE.0)GO TO 337
14850		IF(N.EQ.'G')GO TO 337
14875		IF(N.EQ.'M')GO TO 337
14887		IF(N.NE.'R')GO TO 92
14900	CC337	JJ=MCLEF(1)
15000	337	IF(JS.EQ.'Z')GO TO 306
15100		IF(JS.NE.'S')GO TO 338
15200		CALL SMOOTH(JS)
15300		GO TO 436
15400	338	IC=-1
15500		MM=1
15600		DO 335 K=2,MCLEF(1)
15700		IF(MCLEF(K).LT.200000000)GO TO 335
15800	CC	CALL DPYBRT(3)
15900	CC	CALL RDRAW(K,MCLEF(1),MCLEF)
15910	CC	CALL DPYOUT(1)
16000	CC	CALL DPYBRT(4)
16100	CC	JJ=K-1
16200		IC=K
16300		GO TO 334
16400	C FOR 1ST LOC. OF MCLEF IN FILLER
16500	335	CONTINUE
16600	334	CALL RDRAW(2,MCLEF(1),MCLEF)
16700		CALL DPYOUT(1)
16800		NIST=IST(2)
16900	CC	IF(JJ.EQ.MCLEF(1))GO TO 436
16950		GO TO 436
17000	C NO FILLER
17010	79	IF(IC)GO TO 91
17020	C  IC=-1 IF NO FILLER WAS REQUESTED WHILE DRAWING.
17100	CJ	TYPE 336
17200	CJ	ACCEPT 10,J
17300		JZ=N
17400	CC	IF(J.NE.'Y'.AND.J.NE.'S')GO TO 436
17500		KK=0
17600	CJ	IF(J.NE.'Y')GO TO 206
17605		IF(JC.NE.'S')GO TO 206
17607	C  TYPE 'FS' TO FILL AND SMOOTH
17610	CC	IF(J.NE.'S')GO TO 206
17700	306	CALL SMOOTH(0)
17750	C  SMOOTHS AND FILLS
17800		GO TO 436
17900	206	RR=RSZ
18100		DO 205 J=IC,MCLEF(1)
18200		CALL UNPACK(J,M,N,MCLEF)
18300		KK=KK+1
18400		NF(KK)=0
18500		IF(LL.GE.100000000)NF(KK)=3
18600		QF(KK)=(M+RJB)*RR
18700	205	RF(KK)=(N+CENTR)*RR
18800		NF(1)=KK
18900		CALL FILLQ(QF,RF,NF)
19000	436	IF(JZ.EQ.'P')CALL PLOT(0,0,3)
19100		GO TO 91
19105	
19110	66	TYPE 666,NM
19120		GO TO 91
19130	666	FORMAT(' MORE THAN ONE ITEM IN FILE ',A5/)
19200	336	FORMAT(' SMOOTH? ',$)
19300	10	FORMAT(A5,F)
19400	5	FORMAT(12I)
19500	100   FORMAT(' G=GET, GM=GET MORE, S=SAVE, D=DRAW, M=MOVE, R=ROTATE,'/'
19600		1 P=PLOT, PX=XGP, A=ADD TO SAVED FILE
19650		1, DEL=DEL. FROM FILE, Q=BACKGROUND, Z=ZERO DRAWING'/
19700		1' F=FILL,  E=EDIT,   N1=SIZE, N2=1=GRID '/)
19800	C  N1=20 TO CHANGE SHAPE
19900	
20000	92	IST(2)=NIST
20100		CALL DRAWIT
20200	  	N=0
20300		GO TO 3
20400	
20500	403	FORMAT(' WRITE OVER ',A5,'.DMD?  ',$)
20600	41	FORMAT(' TYPE FILE NAME'/)
20700	C  SAVES ONLY ONE PICTURE - USE 999(COMBINE) FOR UP TO 9
20800	40	IF(LOOKF(NM).EQ.0)GO TO 402
20900		TYPE 403,NM
21000		ACCEPT 50,K
21100		IF(K.EQ.'N')GO TO 191
21200	CC402	IC=MCLEF(1)+1
21210	402	NMLST(1)=NM
21220		JCLEF(1)=1
21230		DO 1111 K=2,10
21240		JCLEF(K)=0
21250	1111	NMLST(K)=' '
21260		CALL RDSAV(JCLEF,NMLST,MCLEF(1),NM,MCLEF,0)
21280		NQ=MCLEF(1)
21300	CC	CALL OFILE(1,NM)
21400	CC	WRITE(1,120),IC
21500	CC	CALL SAVE(MCLEF)
21510	CC	WRITE(1,1111)NM
21555	CC1111	FORMAT(' 9999 ',A5)
21600	111	TYPE 110,NQ
21610	CC	END FILE(1)
21615	CC	TYPE 1111,NM
21620		GO TO 91
21700	CC120	FORMAT(' 9999  1 ',I4,' 0 0 0 0 0 0 0 0')
21800	110	FORMAT(' TOTAL WDS=',I3)
21900		END